home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / check.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  105 lines
  1.  
  2. ; The barest skeleton of a test suite.
  3. ; Mostly it makes sure that many of the external packages load without
  4. ; error.
  5.  
  6. ; ,exec ,load debug/check.scm
  7. ; (done)
  8.  
  9. (load-package 'testing)
  10.  
  11. (config '(run 
  12.       (define-structure bar (export)
  13.         (open scheme testing))))
  14.  
  15. (in 'bar '(bench off))
  16. (in 'bar '(run (define (foo) (cadr '(a b)))))
  17. (in 'bar '(run (define cadr list)))
  18. (in 'bar '(run (test "non-bench" equal? '((a b)) (foo))))
  19.  
  20. (in 'bar '(bench on))
  21. (in 'bar '(run (define (foo) (car '(a b)))))
  22. (in 'bar '(run (define car list)))
  23. (in 'bar '(run (test "bench" equal? 'a (foo))))
  24.  
  25. (config '(run 
  26. (define-structure foo (export)
  27.   (open scheme testing
  28.     assembler
  29.     queues
  30.     random
  31.     sort
  32.     big-scheme
  33.     arrays
  34.     dump/restore
  35.     search-trees
  36.     threads
  37.     sicp)
  38.   (begin
  39.  
  40. (test "* 1" = 6 (* 1 2 3))
  41. (test "* 2" = (* 214760876 10) 2147608760)
  42. (test "* 3" = (* 47123 46039) 2169495797)
  43. (test "apply" equal? '(1 2 3 4) (apply list 1 2 '(3 4)))
  44. (test "char<->integer" eq? #\a (integer->char (char->integer #\a)))
  45. (test "lap" equal? #f ((lap #f (false) (return))))
  46. (let ((q (make-queue)))
  47.   (enqueue q 'a)
  48.   (test "q" eq? 'a (dequeue q)))
  49. (test "random" <= 0 ((make-random 7)))
  50. (test "sort" equal? '(1 2 3 3) (sort-list '(2 3 1 3) <))
  51. (test "bigbit" = (expt 2 100) (arithmetic-shift 1 100))
  52. (test "format" string=? "x(1 2)" (format #f "x~s" '(1 2)))
  53. (test "destructure" eq? 'a (destructure (((x (y) z) '(b (a) c))) y))
  54. (test "array" eq? 'a
  55.       (let ((a (make-array 'b 3 4)))
  56.     (array-set! a 'a 1 2)
  57.     (array-ref a 1 2)))
  58. (test "receive" eq? 'a (receive (x y) (values 'b 'a) y))
  59. (let ((z '(a "b" 3 #t)))
  60.   (test "dump" equal? z
  61.     (let ((q (make-queue)))
  62.       (dump z (lambda (c) (enqueue q c)) -1)
  63.       (restore (lambda () (dequeue q))))))
  64. (with-multitasking
  65.  (lambda ()
  66.    (let* ((cv (make-condvar))
  67.       (th (spawn (lambda ()
  68.                (relinquish-timeslice)
  69.                (condvar-set! cv 'foo))
  70.              'test)))
  71.      (test "threads" eq? 'foo (condvar-ref cv)))))
  72. (test "explode" equal? 'ab3 (implode (explode 'ab3)))
  73. (test "get/put" equal? 'a (begin (put 'foo 'prop 'a)
  74.                  (get 'foo 'prop)))
  75. (test "search-trees" eq? 'a
  76.       (let ((t (make-search-tree = <)))
  77.     (search-tree-set! t 3 'b)
  78.     (search-tree-set! t 4 'a)
  79.     (search-tree-set! t 5 'c)
  80.     (search-tree-ref t 4)))
  81.  
  82. ))))
  83.  
  84. (load-package 'foo)
  85.  
  86. (load-package 'floatnums)
  87.  
  88. (in 'foo '(run (let* ((one (exact->inexact 1))
  89.               (three (exact->inexact 3))
  90.               (third (/ one three))
  91.               (xthird (inexact->exact third)))
  92.          (test "float" eq? #f (= 1/3 xthird))
  93.          (test "exact<->inexact" = third (exact->inexact xthird)))))
  94.  
  95.  
  96. ; All done.
  97.  
  98. (if (in 'testing '(run (lost?)))
  99.     (display "Some tests failed.")
  100.     (display "All tests succeeded."))
  101. (newline)
  102.  
  103. (define (done)
  104.   (exit (if (in 'testing '(run (lost?))) 1 0)))
  105.